home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / sml_nj / 93src.lha / src / runtime / mac / MacExpImp.c < prev    next >
Encoding:
C/C++ Source or Header  |  1993-02-09  |  14.1 KB  |  580 lines
  1. /* MacExpImp.c */
  2. /*
  3.  * 07Jan92  e   export() and corresponding import() for SMLNJ for the Mac.
  4.  *
  5.  * uses stuff from:
  6.  *
  7. /* gc.c
  8.  *
  9.  * COPYRIGHT (c) 1989 by AT&T Bell Laboratories.
  10.  */
  11.  
  12. #define DBG_WTF 1
  13.  
  14. #include "tags.h"
  15. #include "ml_state.h"
  16. #include "ml_types.h"
  17.  
  18. #include "os_mac.h"
  19.  
  20. #include "eventchk.h"        /* 25Jan93  e */
  21.  
  22. /** This stuff used to be in "descriptor.h."  It should probably be merged with
  23.  ** the definitions in "ml_types.h."
  24.  **/
  25.  
  26. #define is_ptr(x)    (((int)(x)&0x3) == 0)
  27. #define mask_tags    (power_tags-1)
  28. #define get_len(x)    (*(int *)(x)>>width_tags)
  29. #define get_lenz(x)    ((((*(int*)(x)) & mask_tags) == TAG_special) ? 1 : get_len(x))
  30. #define get_strlen(x)    (((*(int *)(x)>>width_tags)+3) >> 2)
  31. #define get_realarraylenw(x)    (get_len(x) << 1)  /* word len */
  32. #define get_realarraylenb(x)    (get_len(x) << 3)  /* byte len */
  33. #define tag_from_desc(d)    ((d) & mask_tags)
  34. #define get_tag(x)        tag_from_desc(*(int *)(x))
  35.  
  36. /* return true if "m" points to the descriptor word of a code string. */
  37. #define isCodeString(m)        \
  38.     (((get_len(m) & 1) == 0) && ((*((m)+2)) == MAKE_DESC(1,TAG_backptr)))
  39.  
  40. /* Given a 6-bit tag, return true if is the tag of an object that cannot
  41.  * contain pointers.
  42.  */
  43. static char hasNoPtrs[16] = {
  44.     0, 1, 1, 0,     /* pair, reald, emb_reald, unused */
  45.     0, 1, 0, 0,    /* special, backptr, unused, forwarded */
  46.     0, 0, 1, 1,    /* record, array, string, emb_string */
  47.     1, 1, 0, 0    /* bytearray, realdarray, unused, unused */
  48.     };
  49. #define ContainsNoPtrs(x)    (hasNoPtrs[((x)>>2)&0xF])
  50.  
  51. /* end of stuff from gc.c */
  52.  
  53. /* refcells from callgc.c */
  54.  
  55. extern int active_procs0[];
  56. extern int collected0[];
  57. extern int collectedfrom0[];
  58. extern int times0[];        /* new */
  59. extern int current0[];
  60. extern int gcmessages0[];
  61. extern int majorcollections0[];
  62. extern int minorcollections0[];
  63. extern int pstruct0[];
  64. extern int ratio0[];
  65. extern int softmax0[];
  66. extern int lastratio0[];
  67. extern int sighandler0[];
  68. extern int errstrings[];
  69. /* see below extern int externlist0[]; */
  70.  
  71. #define collected (collected0[1])
  72. #define collectedfrom (collectedfrom0[1])
  73. #define current (current0[1])
  74. #define gcmessages (gcmessages0[1])
  75. #define majorcollections (majorcollections0[1])
  76. #define minorcollections (minorcollections0[1])
  77. #define pstruct (pstruct0[1])
  78. #define ratio (ratio0[1])
  79. #define softmax (softmax0[1])
  80. #define lastratio (lastratio0[1])
  81. /* refcells from mp.c */
  82. #define active_procs (active_procs0[1])
  83.  
  84. extern void restart_gc(MLState_ptr);
  85. extern MLState_ptr Exporters_State;
  86.  
  87. extern int        arenabase;        /* bottom of the heap */
  88. extern int        arenasize;        /* heap starts empty */
  89. extern int        lastbreak;
  90. extern int        new_size;
  91. extern int        arstart;        /* beginning of allocation arena */
  92. extern int        arend;            /* end of main arena, and the heap */
  93. extern int        old_high;        /* marks end of persistent heap */
  94. extern ML_val_t        store_preserve;        /* s.b. ML_val_t */
  95.  
  96. /* end of stuff from callgc.c */
  97.  
  98. /* from cfuns.c */
  99.  
  100. struct table_t {
  101.     int            tag;
  102.     ML_val_t        func;
  103.     ML_val_t        name;
  104.     ML_val_t        next;
  105.     int            stag;
  106.     char        str[16];
  107. };
  108.  
  109. extern struct table_t externlist0[];
  110.  
  111. /* won't work! #define NEXTERNS    (sizeof(externlist0)/sizeof(struct table_t)) */
  112. extern int nexterns;
  113.  
  114. /* end of stuff from cfuns.c */
  115.  
  116. extern MLState_t    *MLproc;
  117. extern int        datalist[];            /* s.b. ML_val_t */
  118.  
  119. #include <unix.h>
  120. #include <fcntl.h>
  121. #include <errno.h>
  122. #include <LoMem.h>
  123.  
  124. #define DUMP(p,sz) if(write(fd,((char *)p),(sz))<0) return(-1)
  125. #define LOAD(p,sz) if( read(fd,((char *)p),(sz))<0) return(-1)
  126.  
  127. static int eMAGIC = 0x357;
  128. static int eVERSION = 103;
  129.  
  130. extern ML_val_t cstruct[];
  131. extern ML_val_t mathvec[];
  132. extern ML_val_t runvec[];
  133. extern int array0_v[];
  134. extern int bytearray0_v[];
  135. extern int realarray0_v[];
  136. extern int vector0_v[];
  137.  
  138. /* from run_ml.c */
  139.  
  140. extern int profile_array[];
  141.  
  142. /* magic constants from cstruct.c */
  143.  
  144. #define CSTRUCT_SZ    28
  145. #define MATHVEC_SZ    9
  146. #define RUNVEC_SZ    12
  147.  
  148. extern int handle_v[];
  149.  
  150. extern int return_v[];
  151. extern ML_val_t *return_c;        /* == return_v+1 */
  152. extern int sigh_return_v[];
  153. extern ML_val_t *sigh_return_c;        /* == sigh_return_v+1 */
  154.  
  155. /* from ml_objects.c */
  156.  
  157. extern int string0[];
  158.  
  159. /* e's stuff */
  160.  
  161. #define OLDVEC_SZ 8
  162.  
  163. #if DBG_WTF > 1
  164.  
  165. #define DBGprintf(x,y) chatting(x,y,z)
  166.  
  167. #else
  168.  
  169. void DBGprintf( char *x, int y, int z )
  170. {
  171.   if (gcmessages >= (int )INT_CtoML(4)) chatting(x,y,z);
  172. }
  173.  
  174. #endif
  175.  
  176. static int old_cstruct[CSTRUCT_SZ+1];
  177. static int old_mathvec[MATHVEC_SZ+1];
  178. static int old_runvec[RUNVEC_SZ+1];
  179. /* ugh static int old_extern[NEXTERNS]; */
  180. extern int old_extern[];
  181. static int old_vecvec[OLDVEC_SZ];
  182.  
  183. void init_old_vecs()
  184. {
  185.     int            i;
  186.     struct table_t  *p = (struct table_t *)INT_CtoML(0);
  187.  
  188.     blockmove( cstruct, old_cstruct, CSTRUCT_SZ+1 );
  189.     blockmove( mathvec, old_mathvec, MATHVEC_SZ+1 );
  190.     blockmove( runvec, old_runvec, RUNVEC_SZ+1 );
  191.     old_vecvec[0] = (int )&cstruct[1];
  192.     old_vecvec[1] = (int )&mathvec[1];
  193.     old_vecvec[2] = (int )&runvec[1];
  194.     old_vecvec[3] = (int )&handle_v[1];
  195.     old_vecvec[4] = (int )&profile_array[1];
  196.     old_vecvec[5] = (int )&string0[1];
  197.     old_vecvec[6] = (int )return_c;
  198.     old_vecvec[7] = (int )sigh_return_c;
  199.  
  200.     for (i = nexterns;  --i >= 0; ) {
  201.     old_extern[i] = (int )externlist0[i].func;
  202.     }
  203. }
  204.  
  205. static int ewtf( int z )
  206. {
  207.     int i;
  208.     int *p;
  209.  
  210.     for ( p = (int *)&old_cstruct[1], i = 1; i <= CSTRUCT_SZ; p++, i++ )    {
  211.     if ( z == *p )    {
  212.         DBGprintf( "\n wtf: 0x%x found, cstruct: %d", z, i );
  213.         return (int )cstruct[i];
  214.     }
  215.     }
  216.     if ( z == old_vecvec[0] )    {
  217.         DBGprintf( "\n wtf: 0x%x found, cstruct", z, 0 );
  218.         return (int )&cstruct[1];        
  219.     }
  220.     if ( z == old_vecvec[1] )    {
  221.         DBGprintf( "\n wtf: 0x%x found, mathvec", z, 0 );
  222.         return (int )&mathvec[1];        
  223.     }
  224.     if ( z == old_vecvec[2] )    {
  225.         DBGprintf( "\n wtf: 0x%x found, runvec", z, 0 );
  226.         return (int )&runvec[1];        
  227.     }
  228.     if ( z == old_vecvec[3] )    {
  229.         DBGprintf( "\n wtf: 0x%x found, handle_v", z, 0 );
  230.         return (int )&handle_v[1];        
  231.     }
  232.     if ( z == old_vecvec[4] )    {
  233.         DBGprintf( "\n wtf: 0x%x found, profile_array", z, 0 );
  234.         return (int )&profile_array[1];        
  235.     }
  236.     if ( z == old_vecvec[5] )    {
  237.         DBGprintf( "\n wtf: 0x%x found, string0", z, 0 );
  238.         return (int )&string0[1];        
  239.     }
  240.     if ( z == old_vecvec[6] )    {
  241.         DBGprintf( "\n wtf: 0x%x found, return_c", z, 0 );
  242.         return (int )return_c;        
  243.     }
  244.     if ( z == old_vecvec[7] )    {
  245.         DBGprintf( "\n wtf: 0x%x found, sigh_return_c", z, 0 );
  246.         return (int )sigh_return_c;        
  247.     }
  248.     for ( p = (int *)&old_mathvec[1], i = 1; i <= MATHVEC_SZ; p++, i++ )    {
  249.     if ( z == *p )    {
  250.         DBGprintf( "\n wtf: 0x%x found, mathvec: %d", z, i );
  251.         return (int )mathvec[i];
  252.     }
  253.     }
  254.     for ( p = (int *)&old_runvec[1], i = 1; i <= RUNVEC_SZ; p++, i++ )    {
  255.     if ( z == *p )    {
  256.         DBGprintf( "\n wtf: 0x%x found, runvec: %d", z, i );
  257.         return (int )runvec[i];
  258.     }
  259.     }
  260.     for (i = nexterns;  --i >= 0; ) {
  261.     if ( z == old_extern[i] )    {
  262.         DBGprintf( "\n wtf: 0x%x found, extern: %d", z, i );
  263.         return (int )externlist0[i].func;
  264.     }
  265.     }
  266.     chatting( "\n[ warning! wtf: 0x%x not found! ]", z );
  267.     return (int )INT_CtoML(0);
  268. }
  269.  
  270. static int verify_arena()
  271. {
  272.     int *x = (int *)arenabase, *done = (int *)old_high;
  273.  
  274. #define ewtfMAC(x) (is_ptr(x)?(((x)>=arenabase&&(x)<old_high)?(x):(ewtf(x))):(x))
  275.  
  276.     if ( store_preserve != INT_CtoML(0) )
  277.         printf( "\n store_preserve non-NIL!" );
  278.  
  279.     {    MLState_t   *p;
  280.     int i, mask;
  281.     
  282.     p = &(MLproc[0]);
  283.  
  284.     ewtfMAC((int )p->ml_pc);
  285.     ewtfMAC((int )p->ml_exncont);
  286.     ewtfMAC((int )p->ml_varptr);
  287.  
  288.     mask = p->mask;
  289.     for (i = 0;  mask != 0;  i++, mask >>= 1) {
  290.       if ((mask & 1) != 0) ewtfMAC((int )p->ml_roots[ArgRegMap[i]]);
  291.     }
  292.     }
  293.  
  294.     ewtfMAC(pstruct);
  295.     ewtfMAC(current);
  296.     ewtfMAC(times0[1]);
  297.     ewtfMAC(sighandler0[1]);
  298.  
  299.     while (x < done) {
  300.     int tag = get_tag(x);
  301.     if (ContainsNoPtrs(tag)) {
  302.         if (tag == TAG_reald) x += 3;
  303.         else if (tag == TAG_realdarray) x += (get_realarraylenw(x) + 1);
  304.         else x += (get_strlen(x) + 1);
  305.     }
  306.     else {
  307.         register int i = get_lenz(x);
  308.         register int z;
  309.         ++x;
  310.         do {
  311.         z = *x;
  312. #if 0
  313.         if (is_ptr(z=*x))
  314.             if (z >= arenabase && z < old_high)
  315.             /* *x += adjust */ ;
  316.             else
  317.             /* *x = */ ewtf(z);
  318. #else
  319.         if ( ( z < arenabase || z >= old_high ) && (! ( z & 1 )) )
  320.             ewtf(z);
  321. #endif
  322.         x++;
  323.         } while (--i > 0);
  324.     }
  325.     MAYBE_EVENTCHK();
  326.     }
  327.     DBGprintf( "\n", 0, 0 );
  328. }
  329.  
  330. int export_guts(fd) /* nonzero return means error, check errno */
  331. int fd;
  332.     {
  333.     /* dump file header for verification */
  334.     DUMP(&eMAGIC, 4);
  335.     DUMP(&eVERSION, 4);
  336.  
  337.     /* dump addresses for import relocation */
  338.     DUMP(&arenabase, 4);
  339.     DUMP(&old_high, 4);
  340.     DUMP(&arstart, 4);
  341.  
  342.     /* dump ml_state */
  343.     /* DUMP(&(MLproc[0]), sizeof(MLState_t)); */ /* ????????? */
  344.     DUMP(&(MLproc->mask), 4);        /* real roots */
  345.     DUMP(MLproc, 12+NROOTS*4);        /* = 11 ML registers */
  346.  
  347.     /* dump A5 world */
  348.     DUMP(old_cstruct, (CSTRUCT_SZ+1)<<2 );
  349.     DUMP(old_mathvec, (MATHVEC_SZ+1)<<2 );
  350.     DUMP(old_runvec, (RUNVEC_SZ+1)<<2 );
  351.     DUMP(old_extern, nexterns<<2 );
  352.     DUMP(old_vecvec, (OLDVEC_SZ)<<2 );
  353.  
  354.     /* dump refcells */      
  355.     DUMP(&pstruct, 4);
  356.     DUMP(¤t, 4);
  357.     DUMP(&(sighandler0[1]), 4);        /* proc */
  358.  
  359.     DUMP(&active_procs, 4);            /* int */
  360.  
  361.     DUMP(&gcmessages, 4);            /* int */
  362.     
  363.     DUMP(&(times0[1]), 4);            /* new */
  364.     DUMP(&collected, 4);            /* reload the following cells? */
  365.     DUMP(&collectedfrom, 4);
  366.     DUMP(&majorcollections, 4);
  367.     DUMP(&minorcollections, 4);
  368.     DUMP(&ratio, 4);
  369.     DUMP(&softmax, 4);
  370.     DUMP(&lastratio, 4);
  371.  
  372.     /* DUMP(&(datalist[1]), 12);        /* no */
  373.  
  374.     /* dump heap */      
  375.     DUMP((void*)arenabase, (old_high - arenabase));
  376.       
  377.     return(0);
  378. }
  379.  
  380. int export(fd) /* nonzero return means error, check errno */
  381. int fd;
  382. {
  383.     init_old_vecs();
  384. #if DBG_WTF > 0
  385.     verify_arena();
  386. #endif
  387.     export_guts(fd);
  388.     return(0);
  389. }
  390.  
  391. /* like relocate() in gc.c */
  392.  
  393. e_relocate (start, end, stuff)
  394.     int start, end;
  395.     int *stuff;
  396. {
  397.     int *x = stuff, *done = stuff + (end-start)/4;
  398.     int adjust = ((int)stuff) - start;
  399.  
  400.     while (x < done) {
  401.     int tag = get_tag(x);
  402.     if (ContainsNoPtrs(tag)) {
  403.         if (tag == TAG_reald) x += 3;
  404.         else if (tag == TAG_realdarray) x += (get_realarraylenw(x) + 1);
  405.         else x += (get_strlen(x) + 1);
  406.     }
  407.     else {
  408.         register int i = get_lenz(x);
  409.         register int z;
  410.         ++x;
  411.         do {
  412. #if 0
  413.         /* is_ptr() returns false for pointers into Mac space = 2mod4 */
  414.         if (is_ptr(z=*x))
  415.             if (z >= start && z < end)
  416.             *x += adjust;
  417.             else
  418.             *x = ewtf(z);
  419. #else
  420.         z = *x;
  421.         if ( z >= start && z < end ) { if (is_ptr(z)) *x += adjust; }
  422.         else                 { if (! (z & 1)) *x = ewtf(z); }
  423. #endif
  424.         x++;
  425.         } while (--i > 0);
  426.     }
  427.     MAYBE_EVENTCHK();
  428.     }
  429. }
  430.  
  431. int import(fd) /* nonzero return means error, check errno */
  432.     int fd;
  433. {
  434.     int hp_offset, mask, size, i, bit_bucket[2];
  435.     int dumped_arenabase, dumped_old_high;
  436.     /* register int *p; */
  437.     register int  x;
  438.     MLState_t   *p;
  439.  
  440.     /* load file header for verification */
  441.     LOAD(bit_bucket, 8);
  442.     if(bit_bucket[0] != eMAGIC || bit_bucket[1] != eVERSION) {
  443.         errno = EDOM;
  444.         return(1);
  445.     }
  446.  
  447.     /* load addresses for import relocation */
  448.     LOAD(&dumped_arenabase, 4);
  449.     LOAD(&dumped_old_high, 4);
  450.     LOAD(&arstart, 4);
  451.     
  452.     hp_offset = arenabase - dumped_arenabase;
  453.     size = dumped_old_high - dumped_arenabase;
  454.     if(brk((int)arenabase + size))
  455.         die("loader: not enough memory");
  456.     arstart += hp_offset;                        /* ??? */
  457.     old_high = dumped_old_high + hp_offset;
  458.     
  459.     /* load ml_state */
  460.     /* LOAD(&(MLproc[0]), sizeof(MLState_t)); */ /* ????????? */
  461.     LOAD(&(MLproc[0].mask), 4);        /* real roots */
  462.     LOAD(&(MLproc[0]), 12+NROOTS*4);    /* = 11 ML registers */
  463.  
  464.     /* load A5 world */
  465.     LOAD(old_cstruct, (CSTRUCT_SZ+1)<<2 );
  466.     LOAD(old_mathvec, (MATHVEC_SZ+1)<<2 );
  467.     LOAD(old_runvec, (RUNVEC_SZ+1)<<2 );
  468.     LOAD(old_extern, nexterns<<2 );
  469.     LOAD(old_vecvec, (OLDVEC_SZ)<<2 );
  470.  
  471.     /* load refcells */      
  472.     LOAD(&pstruct, 4);
  473.     LOAD(¤t, 4);
  474.     LOAD(&(sighandler0[1]), 4);        /* proc */
  475.  
  476.     LOAD(&active_procs, 4);            /* int */
  477.  
  478.     LOAD(&gcmessages, 4);            /* int */
  479.     
  480.     LOAD(&(times0[1]), 4);            /* new */
  481.     LOAD(&collected, 4);            /* reload the following cells? */
  482.     LOAD(&collectedfrom, 4);
  483.     LOAD(&majorcollections, 4);
  484.     LOAD(&minorcollections, 4);
  485.     LOAD(&ratio, 4);
  486.     LOAD(&softmax, 4);
  487.     LOAD(&lastratio, 4);
  488.  
  489.     /* LOAD(&(datalist[1]), 12);        /* no */
  490.  
  491.     /* load heap */      
  492.  
  493.     LOAD((void*)arenabase, size);
  494.       
  495.     /* adjust */
  496.     
  497.     /* collect_roots from callgc.c was used as the basis for identifying roots */
  498.     /*  each root that it would have collected is dumped to the file "as is"   */
  499.     /*  and is adjusted when imported as follows: */
  500.  
  501. #define ADJ(z) (is_ptr(x=(z))?(((x)>=dumped_arenabase&&(x)<dumped_old_high)\
  502.                   ?((x)+hp_offset):(/*(x)+A5_offset*/ewtf(x))):(x))
  503.  
  504.     /* I used to just try adjusting all the registers...
  505.     for(p = (int *)&(MLproc[0]),i=0; i < (NROOTS+3); i++)
  506.         *p++ = ADJ(*p);
  507.     but this is what collect_roots does... */
  508.     
  509.     p = &(MLproc[0]);
  510.  
  511.     p->ml_pc =     (ML_val_t )ADJ((int )p->ml_pc);
  512.     p->ml_exncont =    (ML_val_t )ADJ((int )p->ml_exncont);
  513.     p->ml_varptr =    (ML_val_t )ADJ((int )p->ml_varptr);
  514.  
  515.     mask = p->mask;
  516.     for (i = 0;  mask != 0;  i++, mask >>= 1) {
  517.       if ((mask & 1) != 0)
  518.         p->ml_roots[ArgRegMap[i]] = (ML_val_t )ADJ((int )p->ml_roots[ArgRegMap[i]]);
  519.     }
  520.  
  521.     pstruct = ADJ(pstruct);
  522.     current = ADJ(current);
  523.     times0[1] = ADJ(times0[1]);
  524.     sighandler0[1] = ADJ(sighandler0[1]);
  525.  
  526.     /* no - we verify that it's NIL at export time...
  527.     store_preserve = (ML_val_t)ADJ((int)store_preserve); */
  528.     /* no - we have no datalist on Mac yet...
  529.     datalist[1] = ADJ(datalist[1]);
  530.     datalist[2] = ADJ(datalist[2]);
  531.     datalist[3] = ADJ(datalist[3]); */
  532.  
  533.     e_relocate( dumped_arenabase, dumped_old_high, arenabase );
  534.  
  535.     return(0);
  536. }
  537.  
  538. #include <Dialogs.h>
  539. #include <Quickdraw.h>
  540. #include <ToolUtils.h>
  541.  
  542. void restarter(char *imageName)
  543.     {
  544.     DialogPtr    dlg;
  545.     int fd;
  546.  
  547.     dlg=GetNewDialog(loading_dlogID,NULL,(WindowPtr)(-1L));
  548.     DrawDialog(dlg);
  549.     SetCursor(*GetCursor(watchCursor));
  550.  
  551.     /* arenabase = lastbreak = sbrk(0);    */
  552.     /* pagesize = ...; */
  553.  
  554.     mp_init(0);
  555.     init_gc(MLproc);
  556.     init_externlist(MLproc);
  557.     Exporters_State = MLproc;
  558.  
  559.     if ((fd = eopen(imageName, O_RDONLY|O_BINARY)) < 3)
  560.         die("restarter: Cannot open %s.\n",imageName);
  561.     if(import(fd))
  562.         die("restarter: Cannot restart %s, %d.\n",imageName,errno);
  563.     close(fd);
  564.  
  565.     DisposDialog(dlg);
  566.     /* SetCursor(&qd.arrow); */
  567.     asm {
  568.         movea.l    (a5),a0
  569.         pea        -108(a0)            ;  arrow
  570.         _SetCursor
  571.     }
  572.     
  573.     Exporters_State = MLproc;
  574.     restart_ml(MLproc);
  575.  
  576.     /* not reached */
  577.  }
  578.  
  579. /* end of MacExpImp.c */
  580.